home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / gsdb21.arc / GS_DB3WK.PAS < prev    next >
Pascal/Delphi Source File  |  1991-01-04  |  13KB  |  418 lines
  1. Unit GS_dB3Wk;
  2. interface
  3.  
  4. Function GS_dB3_Create(fName : string) : boolean;
  5.  
  6. implementation
  7. uses
  8.    CRT,
  9.    DOS,
  10.    GS_FileH,
  11.    GS_KeyI,
  12.    GS_Wind,
  13.    GS_Strng,
  14.    GS_dBase;
  15.  
  16. CONST
  17.    EofMark     : Byte = $1A;          {Byte to indicate end of file}
  18.    EohMark     : Byte = $0D;          {Byte stored at end of the header}
  19.    dB3File     : Byte = $03;
  20.    dB3WithMemo : Byte = $83;
  21.  
  22. type
  23.    FldRecPtr   = ^FldRecTyp;
  24.    FldRecTyp   = array[1..GS_dBase_MaxRecField] of GS_dBase_Field;
  25.  
  26. var
  27.    FileWin,
  28.    StatWin  : GS_Wind_Objt;
  29.    InputStr       : GS_KeyI_Objt;
  30.    FCnt,
  31.    LCnt,
  32.    PCnt,
  33.    BeginFPos      : integer;
  34.    EndFPos        : integer;
  35.    FldRec         : FldRecPtr;
  36.    dFile          : file;
  37.    HeadRec        : GS_dBase_Head;
  38.    FileName       : string;
  39.    rsl,
  40.    yy, mm, dd, wd : word;             {Variables to hold GetDate values}
  41.    rl, i          : integer;          {Working variables}
  42.  
  43. function Quit_Keys : boolean;
  44. begin
  45.    if (GS_KeyI_Esc) or (GS_KeyI_Chr = Kbd_CEnd) then Quit_Keys := true
  46.       else Quit_Keys := false;
  47. end;
  48.  
  49. procedure WriteXYString(x,y,l : integer; s : string);
  50. begin
  51.    GoToXY(x,y);
  52.    write(s,'':l-length(s));
  53. end;
  54.  
  55. procedure WriteXYInteger(x,y,l,v : integer);
  56. begin
  57.    GoToXY(x,y);
  58.    write(v:l);
  59. end;
  60.  
  61.  
  62. procedure ShowFields;
  63. var
  64.    i,j : integer;
  65.    y : integer;
  66.    s : string;
  67.    c : char;
  68.    v : byte;
  69. begin
  70.    if PCnt > FCnt then
  71.    begin
  72.       FillChar(FldRec^[PCnt],32,#0);
  73.       FldRec^[PCnt].FieldType := 'C';
  74.    end;
  75.    if FCnt = 0 then exit;
  76.    ClrScr;
  77.    if FCnt < EndFPos then j := FCnt else j := EndFPos;
  78.    j := pred(BeginFPos+j);
  79.    y := 0;
  80.    for i := BeginFPos to j do
  81.    begin
  82.       inc(y);
  83.       WriteXYInteger(2,y,3,i);
  84.       CnvAscToStr(FldRec^[i].FieldName,s,11);
  85.       WriteXYString(8,y,10,s);
  86.       move(FldRec^[i].FieldType,c,1);
  87.       case c of
  88.          'C' : s := 'Character';
  89.          'D' : s := 'Date';
  90.          'L' : s := 'Logical';
  91.          'N' : s := 'Numeric';
  92.          'M' : s := 'Memo';
  93.       end;
  94.       WriteXYString(20,y,12,s);
  95.       move(FldRec^[i].FieldLen,v,1);
  96.       WriteXYInteger(33,y,6,v);
  97.       if c = 'N' then
  98.       begin
  99.          move(FldRec^[i].FieldDec,v,1);
  100.          WriteXYInteger(43,y,8,v);
  101.       end;
  102.    end;
  103. end;
  104.  
  105.  
  106. function UpDateFields : boolean;
  107. var
  108.    i,
  109.    x,
  110.    y  : integer;
  111.    t  : string;
  112.    c  : char;
  113.    v  : byte;
  114.  
  115.    procedure Get_Name;
  116.    var
  117.       i : integer;
  118.       s : string;
  119.       b : boolean;
  120.    begin
  121.       GS_Wind_SetIvMode;
  122.       CnvAscToStr(FldRec^[PCnt].FieldName,t,11);
  123.       t := TrimR(t);
  124.       repeat
  125.          b := true;
  126.          t := InputStr.EditString(t,8,y,10);
  127.          if (Quit_Keys) then exit;
  128.          t := AllCaps(t);
  129.          s := TrimR(t);
  130.          if s = '' then b := false
  131.          else
  132.          begin
  133.             for i := 1 to FCnt do
  134.             begin
  135.                CnvAscToStr(FldRec^[i].FieldName,s,11);
  136.                if (s = t) and (PCnt <> i) then b := false;
  137.             end;
  138.          end;
  139.          if (GS_KeyI_Chr in [Kbd_UpAr,Kbd_DnAr]) and (t = '') then b := true;
  140.          if not b then SoundBell(BeepTime, BeepFreq);
  141.       until (b) or ((PCnt = FCnt) and (GS_KeyI_Chr = Kbd_UpAr));
  142.       GS_Wind_SetNmMode;
  143.       WriteXYString(8,y,10,t);
  144.       CnvStrToAsc(t,FldRec^[PCnt].FieldName,11);
  145.    end;
  146.  
  147.    procedure Get_Type;
  148.    begin
  149.       WriteXYString(20,y,11,'C,D,L,M,N:');
  150.       GS_Wind_SetIvMode;
  151.       c := '?';
  152.       repeat
  153.          if c <> '?' then SoundBell(BeepTime, BeepFreq);
  154.          if PCnt <= FCnt then
  155.             move(FldRec^[PCnt].FieldType,c,1)
  156.          else c := 'C';
  157.          t := c;
  158.          t := InputStr.EditString(t,31,y,1);
  159.          if Quit_Keys then exit;
  160.          if length(t) > 0 then c := t[1] else c := ' ';
  161.          c := upcase(c);
  162.       until c in ['C','D','L','M','N'];
  163.       GS_Wind_SetNmMode;
  164.       case c of
  165.          'C' : t := 'Character';
  166.          'D' : t := 'Date';
  167.          'L' : t := 'Logical';
  168.          'N' : t := 'Numeric';
  169.          'M' : t := 'Memo';
  170.       end;
  171.       WriteXYString(20,y,12,t);
  172.       if c <> 'N' then ClrEol;
  173.       move(c,FldRec^[PCnt].FieldType,1);
  174.    end;
  175.  
  176.    procedure Get_Length;
  177.    begin
  178.       if c in ['D','L','M'] then
  179.       begin
  180.          if c = 'D' then v := 8
  181.             else if c = 'L' then v := 1
  182.                else v := 10;
  183.       end
  184.       else
  185.       begin
  186.          GS_Wind_SetIvMode;
  187.          x := 0;
  188.          v := 0;
  189.          repeat
  190.             if x <> 0 then SoundBell(BeepTime, BeepFreq);
  191.             move(FldRec^[PCnt].FieldLen,v,1);
  192.             str(v:6,t);
  193.             t := InputStr.EditString(t,33,y,6);
  194.             if Quit_Keys then exit;
  195.             val(t,v,x);
  196.             if v <= 0 then x := 1;
  197.             if v > 255 then x := 1;
  198.          until x = 0;
  199.          GS_Wind_SetNmMode;
  200.       end;
  201.       WriteXYInteger(33,y,6,v);
  202.       move(v,FldRec^[PCnt].FieldLen,1);
  203.    end;
  204.  
  205.    procedure Get_Decimal;
  206.    begin
  207.       v := 0;
  208.       GS_KeyI_Chr := Kbd_Ret;
  209.       if c = 'N' then
  210.       begin
  211.          GS_Wind_SetIvMode;
  212.          x := 0;
  213.          repeat
  214.             if x <> 0 then SoundBell(BeepTime, BeepFreq);
  215.             move(FldRec^[PCnt].FieldDec,v,1);
  216.             str(v:8,t);
  217.             t := InputStr.EditString(t,43,y,8);
  218.             if Quit_Keys then exit;
  219.             val(t,v,x);
  220.             if v < 0 then x := 1;
  221.             if v > pred(FldRec^[PCnt].FieldLen) then x := 1;
  222.          until x = 0;
  223.          GS_Wind_SetNmMode;
  224.          WriteXYInteger(43,y,8,v);
  225.       end;
  226.       move(v,FldRec^[PCnt].FieldDec,1);
  227.    end;
  228.  
  229. begin
  230.    PCnt :=succ(FCnt);
  231.    ShowFields;
  232.    repeat
  233.       LCnt := 0;
  234.       repeat
  235.          y := succ(PCnt-BeginFPos);
  236.          case LCnt of
  237.            0 : begin
  238.                   gotoxy(2,y);
  239.                   write(PCnt:3);
  240.                   GS_KeyI_Chr := ' ';
  241.                   if PCnt > FCnt then
  242.                   begin
  243.                      FillChar(FldRec^[PCnt],32,#0);
  244.                      FldRec^[PCnt].FieldType := 'C';
  245.                   end;
  246.                end;
  247.            1 : Get_Name;
  248.            2 : Get_Type;
  249.            3 : Get_Length;
  250.            4 : Get_Decimal;
  251.          end;
  252.          inc(LCnt);
  253.          case GS_KeyI_Chr of
  254.             Kbd_RTb   : begin
  255.                            dec(LCnt,2);
  256.                            if LCnt < 1 then LCnt := 1;
  257.                         end;
  258.             Kbd_UpAr  : LCnt := 5;
  259.             Kbd_DnAr  : LCnt := 5;
  260.          end;
  261.       until (LCnt > 4) or (Quit_Keys);
  262.       case GS_KeyI_Chr of
  263.          Kbd_Tab,
  264.          Kbd_Ret   : begin
  265.                         inc(PCnt);
  266.                         if PCnt > succ(FCnt) then inc(FCnt);
  267.                      end;
  268.          Kbd_UpAr  : dec(PCnt);
  269.          Kbd_DnAr  : inc(PCnt);
  270.       end;
  271.       if PCnt < 1 then PCnt := 1;
  272.       if PCnt > succ(FCnt) then PCnt := succ(FCnt);
  273.       if PCnt < BeginFPos then
  274.       begin
  275.          BeginFPos := PCnt;
  276.          ShowFields;
  277.       end;
  278.       if PCnt >= BeginFPos+EndFPos then
  279.       begin
  280.          inc(BeginFPos);
  281.          ShowFields;
  282.       end;
  283.    until Quit_Keys;
  284.    if (GS_KeyI_Chr = Kbd_Esc) or (FCnt = 0) then UpdateFields := false
  285.       else UpdateFields := true;
  286. end;
  287.  
  288.  
  289. procedure BuildFile(FName : string);
  290.  
  291. {
  292.             ┌─────────────────────────────────────────────────────┐
  293.             │  The MakeHeader routine formats a dBase III header, │
  294.             │  writes it to the new file, writes the field array  │
  295.             │  to the file, and then writes an End of Header and  │
  296.             │  End of File byte.                                  │
  297.             └─────────────────────────────────────────────────────┘
  298. }
  299.    procedure MakeHeader;
  300.    var
  301.       i, j : integer;                    {Local working variables}
  302.    BEGIN
  303.       HeadRec.DBType := DB3File;   {Set file type to dBase III w/o Memo}
  304. {
  305.              ┌──────────────────────────────────────────────────┐
  306.              │  Using the Turbo Pascal GetDate routine, set     │
  307.              │  the header year, month, and date header bytes.  │
  308.              │  Since the year is given in 19xx format, 1900    │
  309.              │  must be subtracted to give just the last two    │
  310.              │  digits of the year.                             │
  311.              └──────────────────────────────────────────────────┘
  312. }
  313.       GetDate (yy,mm,dd,wd);
  314.       HeadRec.year := yy-1900; {Year}
  315.       HeadRec.month := mm; {Month}
  316.       HeadRec.day := dd; {Day}
  317.       HeadRec.RecCount := 0;       {Set record count in file to zero }
  318.       HeadRec.Location := (FCnt*32) + 33;
  319.                                       {Compute total header size as length of}
  320.                                       {header file information (32 bytes),}
  321.                                       {End of Header mark (1 byte), and the}
  322.                                       {field descriptors (32 bytes each)}
  323.       rl := 1;
  324.       for i := 1 to FCnt do
  325.       begin
  326.          rl := rl + FldRec^[i].FieldLen;
  327.                                       {Compute total record size as delete/}
  328.                                       {undeleted flag (1 byte) plus total of}
  329.                                       {all field lengths. }
  330.          for j := 0 to 10 do
  331.             FldRec^[i].FieldName[j] := UpCase(FldRec^[i].FieldName[j]);
  332.          FldRec^[i].FieldType := UpCase(FldRec^[i].FieldType);
  333.          if FldRec^[i].FieldType = 'M' then
  334.             HeadRec.DBType := DB3WithMemo;
  335.                                       {Set file type to dBase III with Memo}
  336.       end;
  337.       HeadRec.RecordLen := rl;     {Store record length in header}
  338.       FillChar(HeadRec.Reserved,20,#0);
  339.                                       {Store all zeros in reserved portion }
  340.       GS_FileWrite(dFile, 0, HeadRec, 32, rsl);
  341.       GS_FileWrite(dFile, -1, FldRec^, FCnt*32, rsl);
  342.       GS_FileWrite(dFile, -1, EohMark, 1, rsl); {Put EOH marker }
  343.       GS_FileWrite(dFile, -1, EofMark, 1, rsl); {Put EOF marker }
  344.    END;
  345.  
  346. {
  347.             ┌────────────────────────────────────────────────────┐
  348.             │  Beginning of CREATE Procedure.                    │
  349.             │      1.  Assign file with .DBF extension           │
  350.             │      2.  Create and write the dBase III header     │
  351.             │      3.  Store information in objectname object    │
  352.             │      4.  Close the file                            │
  353.             │      5.  Initialize the dBase file.                │
  354.             └────────────────────────────────────────────────────┘
  355. }
  356.  
  357.     procedure MakeMemo;
  358.     begin
  359.        HeadRec.DBType := 1;        {Make a longint value of 1}
  360.        HeadRec.Year := 0;
  361.        HeadRec.Month := 0;
  362.        HeadRec.Day := 0;
  363.        Filename := FName+'.DBT';      {Assign .DBT file extension}
  364.        GS_FileAssign(dFile, FileName, 2048);
  365.        GS_FileRewrite(dFile, 1);      {Create file}
  366.        GS_FileWrite(dFile, 0, HeadRec, 512, rsl);
  367.        GS_FileWrite(dFile, -1, EofMark, 1, rsl);  {Put EOF marker }
  368.        GS_FileClose(dFile);            {Close the file}
  369.     end;
  370.  
  371. begin
  372.    Filename := FName+'.DBF';          {Assign .DBF file extension}
  373.    GS_FileAssign(dFile, FileName,4096);
  374.    GS_FileRewrite(dFile, 1);          {Create file}
  375.    MakeHeader;
  376.    GS_FileClose(dFile);              {Close the file}
  377.    if HeadRec.DBType = DB3WithMemo then MakeMemo;
  378. end;
  379.  
  380. Function GS_dB3_Create(FName : string) : boolean;
  381. begin
  382.    New(FldRec);
  383.    BeginFPos := 1;
  384.    FCnt := 0;
  385.    StatWin.boxname := '[ CREATE FILE ]';
  386.    StatWin.SetWin;
  387.    gotoxy(56,1);
  388.    write('Ctrl-End to Save');
  389.    gotoxy(56,2);
  390.    write('ESC to Abort');
  391.    gotoxy(2,1);
  392.    write('FLD   NAME        TYPE         LENGTH    DECIMALS');
  393.    gotoxy(2,2);
  394.    write('───   ────        ────         ──────    ────────');
  395.    FileWin.SetWin;
  396.    EndFPos := succ(hi(WindMax)-hi(WindMin));
  397.    if UpdateFields then
  398.    begin
  399.       BuildFile(FName);
  400.       GS_dB3_Create := true;
  401.    end
  402.       else GS_dB3_Create := false;
  403.    FileWin.RelWin;
  404.    StatWin.RelWin;
  405.    Dispose(FldRec);
  406. END;                        { GS_dB3Wk_Create }
  407.  
  408. begin
  409.    FileWin.InitWin(2,4,55,24,Yellow,Blue,Yellow,Blue,Yellow,false,'',false);
  410.    StatWin.InitWin(1,1,80,25,LightGray,Blue,Yellow,Blue,Yellow,true,'',true);
  411.    InputStr.Init;
  412.    InputStr.Wait_CR := false;
  413. end.
  414.  
  415.  
  416.  
  417.  
  418.